home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Utilities / Miscellaneous / CopyPaste 3.3.4 / CopyPaste Tools Sourcecode / Save File / Save File.p < prev    next >
Encoding:
Text File  |  1997-06-06  |  3.5 KB  |  144 lines  |  [TEXT/CWIE]
  1. {•This sourcecode is an example for creating a FKey coderesource with•}
  2. {•Metrowerks Pascal. It is copyrighted by Peter Hoerster and released•}
  3. {•for free use in any Shareware or Freeware product as a way to thank all•}
  4. {•programmers who share code snippets. You may put this sources on any•}
  5. {•CD ROM or any Archive Server but you may not sell it. •}
  6.  
  7. {• For comments please write to <hoerster@muenster.de>•}
  8.  
  9. unit SaveFile;
  10.  
  11. interface
  12.  
  13.     uses
  14.         Types, OSUtils, GestaltEqu, Script, notification, Resources, Events,
  15.          PascalA4, QuickDraw, ToolUtils, Memory, LowMem, Scrap,StandardFile;
  16.  
  17.  
  18.  
  19. {$MAIN}
  20.                         
  21.     procedure main;        
  22.  
  23. implementation
  24.  
  25.     
  26.     procedure main;
  27.         var
  28.             oldA4: LongInt;
  29.             myerr: oserr;
  30.             myclipsize: longint;
  31.             myclipHandle: handle;
  32.             longzero, longcount: longint;
  33.             count: longint;
  34.             gsaveref: integer;
  35.             
  36.     function PutFile (saveas: string; var default: string; var gsaveReply: sfreply): OSErr;
  37.         var
  38.             where: Point;
  39.  
  40.     begin
  41.         SetPt(where, 104, 100);
  42.         SFPutFile(where, saveas, default, nil, gsaveReply);
  43.         if not gsaveReply.good then
  44.             PutFile := 1
  45.         else
  46.             begin
  47.                 default := gsaveReply.fname;
  48.                 PutFile := NoErr
  49.             end;
  50.     end;
  51.  
  52.  
  53. function PrepareNewFile (thetype: OSType): boolean;
  54.         var
  55.             myNewFile: string;
  56.             gsaveReply: sfreply;
  57.     begin
  58.         PrepareNewFile := false;
  59.         myNewFile := thetype;
  60.         if PutFile(thetype, myNewFile, gsaveReply) = noerr then
  61.         if Create(gsaveReply.fname, gsaveReply.vRefNum, 'ttxt', thetype) = noerr then
  62.         if FSOpen(gsaveReply.fname, gsaveReply.vRefNum, gsaveref) = noerr then
  63.         if SetEOF(gsaveRef, 0) = noerr then
  64.             PrepareNewFile := true;
  65.     end;
  66.  
  67.  
  68.  
  69.             
  70.     procedure dosave ;
  71.         const
  72.             HeaderSize = 512;            { PICT file header - we ignore this }
  73.         var
  74.             i:longint;
  75.     begin
  76.         gsaveref := 0;
  77.         myclipsize := GetScrap(nil, 'TEXT', count);
  78.         if myclipsize > 0 then
  79.             begin
  80.                 if PrepareNewFile('TEXT') then
  81.                     begin
  82.                         mycliphandle := Tempnewhandle(myclipsize,myerr);
  83.                         if myerr=noerr then 
  84.                             begin
  85.                                 myclipsize := GetScraP(myclipHandle, 'TEXT', count);
  86.                                 if myclipsize > 0 then
  87.                                     begin
  88.                                         Temphlock(mycliphandle,myerr);
  89.                                         if setfpos(gsaveref, fsfromLEOF, 0) = noerr then
  90.                                             if FSWrite(gsaveref, gethandlesize(mycliphandle), mycliphandle^) = noerr then
  91.                                                 ;
  92.                                         Temphunlock(myCliphandle,myerr);
  93.                                     end;
  94.                             end;
  95.                     end;
  96.             end
  97.         else
  98.             begin
  99.                 myclipsize := GetScrap(nil, 'PICT', count);
  100.                 if myclipsize > 0 then
  101.                     begin
  102.                         if PrepareNewFile('PICT') then
  103.                             begin
  104.                                 mycliphandle := Tempnewhandle(myclipsize,myerr);
  105.                                 if myerr=noerr then 
  106.                                     begin
  107.                                         myclipsize := GetScrap(mycliphandle, 'PICT', count);
  108.                                         if myclipsize > 0 then
  109.                                             begin
  110.                                                 Temphlock(mycliphandle,myerr);begin
  111.                                                 longZero := 0;
  112.                                                 longCount := 4;
  113.                                                 for i := 1 to (512 + SizeOf(Picture)) div 4 do
  114.                                                     begin
  115.                                                         if FSWrite(gsaveref, longCount, @longZero) = noerr then
  116.                                                         if SetFPos(gsaveref, fsFromStart, 512) = noErr then
  117.                                                         if FSWrite(gsaveref, myclipsize, mycliphandle^) = noerr then
  118.                                                          ;
  119.                                                     end;
  120.                                                 Temphunlock(myCliphandle,myerr);
  121.                                             end;
  122.                                     end;
  123.                             end;
  124.                     end;
  125.             end;
  126.         end;
  127.         if gsaveref <> 0 then
  128.             begin
  129.                 myerr := FSclose(gsaveref);
  130.                 gsaveref := 0;
  131.             end;
  132.     end;
  133.  
  134.             
  135.             
  136.             
  137.     begin
  138.         oldA4 := SetCurrentA4;
  139.         dosave;
  140.         if (mycliphandle <>nil)&(mycliphandle^<>nil) then
  141.             TempDisposeHandle(myCliphandle,myerr);
  142.         oldA4 := SetA4(oldA4);
  143.     end;
  144. end.